home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 003 / dbsteel1.arc / SORT.BAS < prev    next >
BASIC Source File  |  1983-03-10  |  12KB  |  445 lines

  1. 4 DEFINT K,F,T,L,R,N
  2. 5 DIM K$(55)
  3. 6 DIM FLDN$(1,60),FTY(1,60),FL(1,60)
  4. 8 DIM NREC(17),FD(3),Z$(60),L(50),R(50),F$(17)
  5. 10 CH = 29
  6. 12 GOSUB 8000
  7. 15 GOSUB 13000
  8. 16 H = A
  9. 17 GOSUB 7000
  10. 19 DEFSTR Z
  11. 20 A = H
  12. 25 GOSUB 9000
  13. 30 FLG = 0
  14. 45 L = 0
  15. 50 FOR T = 1 TO NREC(A)
  16. 55 L = L + FL(1,T)
  17. 60 NEXT T
  18. 70 DEFINT T
  19. 90 GOSUB 11000
  20. 100 GOSUB 10000
  21. 400 REM ******  GET DATA FROM DISKS  *******
  22. 403 PRINT FRE(0)
  23. 405 GOSUB 16000
  24. 420 FOR T = 1 TO 30000 
  25. 429 IF T > MRN GOTO 26000
  26. 430 GET #1,T
  27. 433 FOR T1 = 1 TO KTH
  28. 435 N = FD(T1)
  29. 436 IF FTY(1,N) = 1 GOTO 500
  30. 438 IF T1 = 1 THEN X(T) = 0
  31. 439 X(T) = X(T)*1E+06    
  32. 440 ON FTY(1,N) GOTO 500,550,600,650,650
  33. 500 LET X(T) = Z$(N)
  34. 510 GOTO 700
  35. 550 X(T) = CVI(Z$(N)) + X(T)
  36. 560 GOTO 700
  37. 600 X(T) = CVS(Z$(N)) + X(T)
  38. 610 GOTO 700
  39. 650 X(T) = CVD(Z$(N)) + X(T)
  40. 700 NEXT T1
  41. 705 T(T) = T
  42. 710 NEXT T
  43. 1200 LP = 1   
  44. 1210 FLG = 0
  45. 2000 REM
  46. 2010 M = 5000
  47. 2020 GOSUB 30000
  48. 2110 GOSUB 2200
  49. 2120 GOSUB 30000
  50. 2130 GOTO 3000
  51. 2200 REM
  52. 2210 L(1) = 1 
  53. 2220 R(1) = MAXR
  54. 2230 S = 1
  55. 2240 IF (L(S)) < R(S) THEN 2270
  56. 2250    S = S - 1
  57. 2260    GOTO 2640
  58. 2270 I = L(S)
  59. 2280 J = R(S)
  60. 2290 P1= X(J)
  61. 2300 M = (I + J)/2
  62. 2310 IF (J - I<6) THEN 2400
  63. 2320 IF ((P1>X(I)) AND (P1<X(M))) THEN 2400
  64. 2330 IF ((P1<X(I)) AND (P1>X(M))) THEN 2400
  65. 2340 IF ((X(I)<X(M)) AND (X(I)>P1)) THEN 2380
  66. 2350 IF ((X(I)>X(M)) AND (X(I)<P1)) THEN 2380
  67. 2360 SWAP X(M),X(J)
  68. 2365 SWAP T(M),T(J)
  69. 2370 GOTO 2390
  70. 2380 SWAP X(I),X(J)
  71. 2385 SWAP T(I),T(J)
  72. 2390 P1 = X(J)
  73. 2400 WHILE (I<J)          
  74. 2410 WHILE (X(I)< P1)   
  75. 2420 I = I + 1
  76. 2430 WEND     
  77. 2440 J=J-1
  78. 2450 WHILE  (I<J)AND(P1<X(J))  
  79. 2460 J = J-1
  80. 2470 WEND     
  81. 2480 IF (I>=J) THEN 2510
  82. 2490 SWAP X(I),X(J)
  83. 2500 SWAP T(I),T(J)
  84. 2510 WEND      
  85. 2520 J = R(S)
  86. 2530 SWAP X(I),X(J)
  87. 2540 SWAP T(I),T(J)
  88. 2550 IF (I - L(S)>=R(S)-I) THEN 2600
  89. 2560    L(S + 1) = L(S)
  90. 2570    R(S + 1) = I - 1
  91. 2580    L(S) = I + 1
  92. 2590    GOTO 2630
  93. 2600    L(S + 1) = I + 1
  94. 2610    R(S + 1) = R(S)
  95. 2620    R(S) = I - 1 
  96. 2630 S = S + 1
  97. 2640 IF (S > 0) THEN 2240
  98. 2650 RETURN
  99. 3000 REM ********  PUT IN FILE ************
  100. 3100 GOSUB 9100
  101. 3110 Q$ = "B:"+F$(A)
  102. 3200 GOSUB 9200
  103. 3300 FOR Q = 1 TO MAXR
  104. 3310 RN = T(Q)
  105. 3312 GET #1,RN
  106. 3330 LSET Z1$ = Y$
  107. 3340 PUT #2,Q
  108. 3350 NEXT Q
  109. 3500 CLOSE
  110. 3600 GOSUB 15000
  111. 3620 PRINT "SORT FINISHED "
  112. 3630 END
  113. 7000 GOSUB 12000
  114. 7005 OPEN "I",#1,"FFILE"
  115. 7010 INPUT #1,MAXF
  116. 7020 FOR A = 1 TO MAXF
  117. 7030 INPUT #1,A,F$(A),NREC(A),L(A)
  118. 7040 FOR N = 1 TO NREC(A)
  119. 7050 INPUT #1,FLDN$(1,N),FTY(1,N),FL(1,N)
  120. 7055 IF FTY(1,N) = 2 THEN INPUT #1,KY,KEYLIST
  121. 7060 NEXT N
  122. 7065 IF A = AHLD THEN RETURN
  123. 7070 NEXT A
  124. 7080 CLOSE #1
  125. 7100 RETURN
  126. 8000 GOSUB 12000
  127. 8005 OPEN "I",#1,"FFILE"
  128. 8010 INPUT #1,MAXF
  129. 8020 FOR A = 1 TO MAXF
  130. 8030 INPUT #1,A,F$(A),NREC(A),L(A)
  131. 8040 FOR N = 1 TO NREC(A)
  132. 8050 INPUT #1,FLDN$(1,N),FTY(1,N),FL(1,N)
  133. 8055 IF FTY(1,N) = 2 THEN INPUT #1,KY,KEYLIST
  134. 8060 NEXT N
  135. 8070 NEXT A
  136. 8080 CLOSE #1
  137. 8100 RETURN
  138. 9000 REM *******  OPEN FILE SUBROUTINE  *******
  139. 9010 CLOSE #1
  140. 9020 OPEN "R",#1,F$(A),L(A)
  141. 9030 D = 0
  142. 9040 FOR T = 1 TO NREC(A)
  143. 9050 FIELD #1,D AS D$,FL(1,T) AS Z$(T)
  144. 9060 D = D + FL(1,T)
  145. 9070 NEXT T
  146. 9080 RETURN
  147. 9100 REM *******  OPEN FILE SUBROUTINE  *******
  148. 9110 CLOSE #1
  149. 9120 OPEN "R",#1,F$(A),L   
  150. 9140 PRINT " L(A) ";L   
  151. 9150 FIELD #1,L AS Y$    
  152. 9180 RETURN
  153. 9200 REM *******  OPEN FILE SUBROUTINE  *******
  154. 9210 CLOSE #2
  155. 9220 OPEN "R",#2,Q$,L
  156. 9250 FIELD #2,L AS Z1$
  157. 9280 RETURN
  158. 10000 REM *******  INITAL SELECTION  ********
  159. 10010 GOSUB 15000
  160. 10100 PRINT "**************  SORT FILE PROGRAM  **************"
  161. 10105 PRINT "FILE NUMBER = ";A;" FILE NAME = ";F$(A)
  162. 10110 PRINT ""
  163. 10120 FOR T = 1 TO NREC(A)
  164. 10130 PRINT T;"- ";FLDN$(1,T)
  165. 10140 NEXT T
  166. 10150 PRINT ""
  167. 10160 PRINT "***  HOW MANY FIELDS DO YOU WANT TO SORT BY ? ***"
  168. 10170 PRINT "**************  ENTER  1,2, OR 3  ***************"
  169. 10180 GOSUB 60000
  170. 10185 IF DT#<1 OR DT#>3 GOTO 10180
  171. 10190 KTH= DT#
  172. 10200 PRINT "***  WHICH FIELD IS THE PRIMARY SORT FIELD ?  ***"
  173. 10210 GOSUB 60000
  174. 10212 IF DT#<1 OR DT#>NREC(A) GOTO 10210
  175. 10215 T3 = FD(1)
  176. 10218 FD(1) = DT#
  177. 10219 T3 = DT#
  178. 10220 IF KTH= 1 GOTO 10275 
  179. 10230 PRINT "***********  WHICH FIELD IS THE SECONDARY FIELD ?  **********"
  180. 10232 PRINT "- If the primary values are equal"  
  181. 10234 PRINT "the record with the lowest secondary value will be stored first "
  182. 10240 GOSUB 60000
  183. 10242 IF DT#<1 OR DT#>NREC(A) GOTO 10240
  184. 10244 IF FTY(1,DT#) = 1 GOTO 10410
  185. 10246 FD(2) = DT#
  186. 10250 IF KTH= 2 GOTO 10275
  187. 10260 PRINT "************  WHICH FIELD IS THE THIRD FIELD  ? *************"
  188. 10262 PRINT "- If both the primary value and the secondary value are equal"
  189. 10264 PRINT "the record with the lowest third value will be stored first"
  190. 10270 GOSUB 60000
  191. 10272 IF DT#<1 OR DT#>NREC(A) GOTO 10270
  192. 10273 IF FTY(1,DT#) = 1 GOTO 10410
  193. 10274 FD(3) = DT#
  194. 10275 ON FTY(1,T3) GOSUB 10400,10600,10500,10500,10500
  195. 10280 RETURN
  196. 10400 DEFSTR X,P
  197. 10410 IF KTH> 1 THEN PRINT "********  STRING VARIABLES MAY ONLY BE SORTED BY ONE FIELD  ********"
  198. 10420 IF KTH> 1 GOTO 10100
  199. 10430 DIM X(3000),T(3000)
  200. 10490 RETURN
  201. 10500 DEFDBL X,P
  202. 10505 DIM X(3000),T(3000)
  203. 10510 RETURN
  204. 10600 IF KTH> 1 GOTO 10500
  205. 10610 DEFINT X,P
  206. 10620 DIM X(6000),T(6000)
  207. 10630 RETURN
  208. 11000 REM  *******  INTRODUCTION  ********
  209. 11100 GOSUB 15000
  210. 11110 PRINT "************************  SORT PROGRAM  *************************"
  211. 11114 PRINT ""
  212. 11116 PRINT "        Copyright 1984 by Potomac Pacific Engineering "
  213. 11120 PRINT ""
  214. 11130 PRINT "FILE NUMBER : ";A;" FILE NAME : ";F$(A)
  215. 11140 PRINT ""
  216. 11200 PRINT ""
  217. 11210 PRINT "Up to  6000 records may be sorted on ONE INTEGER FIELD "
  218. 11220 PRINT "Up to  3000 records may be sorted on ONE ALFANUMRIC FIELDS "
  219. 11230 PRINT "Up to  3000 records may be sorted on THREE DIFFERENT NUMERIC FIELDS"
  220. 11240 PRINT "  Depending on what version of Basic you are using you may be able"
  221. 11250 PRINT "to increase the number of records you can sort by changing the "
  222. 11260 PRINT "DIM (dimension) statement in lines 10400 -10630.  The compiled
  223. 11270 PRINT "Version can handle 10000,42000, and 42000 records respectfully."
  224. 11300 PRINT ""
  225. 11310 PRINT "The sort program reads the file on the default disk drive, sorts"
  226. 11320 PRINT "the records, then writes a sorted file with the same file name"
  227. 11330 PRINT "on a disk drive B. "
  228. 11940 PRINT ""
  229. 11950 PRINT "******************  PRESS ANY KEY TO CONTINUE  ******************"
  230. 11960 IF INKEY$ = "" GOTO 11960
  231. 11970 RETURN
  232. 12000 REM *****
  233. 12005 GOSUB 15000
  234. 12010 PRINT "     Put the DATA floppy disk in the default disk drive "
  235. 12020 PRINT ""
  236. 12030 PRINT "         ******  PRESS ANY KEY TO CONTINUE  ***** "
  237. 12040 IF INKEY$ = "" GOTO 12040
  238. 12050 RETURN
  239. 13000 REM *****  
  240. 13100 GOSUB 15000
  241. 13110 PRINT "******************  SORT PROGRAM  *******************"
  242. 13120 PRINT ""
  243. 13130 PRINT "**********  WHICH FILE DO YOU WANT TO SORT  *********"
  244. 13140 FOR T = 1 TO MAXF
  245. 13150 PRINT T;" - ";F$(T)
  246. 13160 NEXT T
  247. 13170 PRINT "*****  ENTER THE FILE NUMBER THEN PRESS RETURN  ******"
  248. 13180 GOSUB 60000
  249. 13185 IF DT#<1 OR DT# >MAXF GOTO 13180
  250. 13190 A = DT#
  251. 13195 AHLD = A
  252. 13200 RETURN
  253. 14000 REM *****  SORT SELECTION
  254. 14100 GOSUB 15000
  255. 14110 PRINT "*******************  SORT PROGRAM  ********************"
  256. 14120 PRINT ""
  257. 14130 PRINT "DO YOU WANT TO SORT A FILE ON :"
  258. 14140 PRINT ""
  259. 14150 PRINT " 1. ONLY ONE INTEGER FIELD"
  260. 14160 PRINT ""
  261. 14170 PRINT " 2. ONE TO THREE NUMERIC FIELDS "
  262. 14180 PRINT ""
  263. 14190 PRINT " 3. A STRING FIELD"
  264. 14200 PRINT ""
  265. 14300 PRINT "*******  ENTER THE NUMBER THEN PRESS RETURN  ********"
  266. 14400 GOSUB 60000
  267. 14410 T = DT#
  268. 14420 ON T GOTO 14500,14700,14900
  269. 14500 REM 
  270. 14520 GOSUB  12000
  271. 14540 RUN "SORTINT"
  272. 14700 GOTO 10
  273. 14900 REM 
  274. 14920 GOSUB 12000
  275. 14940 RUN "SORTSTR"
  276. 15000 REM ******  CLEAR SCREEN 
  277. 15010 CLS 
  278. 15020 RETURN
  279. 16000 REM ******  FIND MAX RECORD 
  280. 16100 MRN = LOF(1)/L(A)
  281. 16200 RETURN
  282. 26000 REM ******* ON ERROR ROUTINE ************
  283. 26200 PRINT "END OF FILE"
  284. 26205 MAXR = T - 1
  285. 26206 PRINT MAXR," MAX RECORD "
  286. 26210 GOTO 1200
  287. 30000 FOR T = 1 TO MAXR
  288. 31000 PRINT X(T)
  289. 32000 NEXT T
  290. 33000 RETURN
  291. 60000 REM *******  INTEGER LESS THEN 100 CHECK  ********
  292. 60010 MAX = 2
  293. 60020 ACT$ = "1234567890=<>^"
  294. 60030 IF NE = 0 THEN ACT$ = "1234567890"
  295. 60040 PRINT ">__<";
  296. 60050 GOTO 60240
  297. 60060 REM *******  INTEGER *******                        
  298. 60070 MAX = 8
  299. 60080 ACT$ = "1234567890-+,=<>^"
  300. 60090 IF NE = 0 THEN ACT$ = "1234567890-+,"
  301. 60100 PRINT ">________<";
  302. 60110 GOTO 60240
  303. 60120 REM *******  SINGLE PRECISION  *******                        
  304. 60130 MAX = 10
  305. 60140 ACT$ = "1234567890-+,.%$=<>^"
  306. 60150 IF NE = 0 THEN ACT$ = "1234567890+-,.%$"
  307. 60160 PRINT ">__________<";
  308. 60170 GOTO 60240
  309. 60180 REM *******  DOUBLE PRECISION  *******                        
  310. 60190 MAX = 20
  311. 60200 ACT$ = "1234567890-+,.%$=<>^"
  312. 60210 IF NE = 0 THEN ACT$ = "1234567890+-,.%$"
  313. 60220 PRINT ">____________________<";
  314. 60230 GOTO 60240
  315. 60240 REM ********** NUMBER CHECK **********
  316. 60250 A$ = ""
  317. 60260 K$(20) = " "
  318. 60270 KTMAX = 0
  319. 60280 FOR T9 = 1 TO MAX
  320. 60290 K$(T9) = " "
  321. 60300 NEXT T9
  322. 60310 DIG$ = "1234567890."
  323. 60320 DOTFLG = 0
  324. 60330 T2 = MAX + 1
  325. 60340 FOR T6 = 1 TO T2
  326. 60350 PRINT CHR$(CH);
  327. 60360 NEXT T6
  328. 60370 IF INKEY$ = "" GOTO 60380 ELSE GOTO 60370
  329. 60380 KT = 0
  330. 60390 REM ***********  CHECK ALFANUMERIC INPUT FOR LENGTH  ***********
  331. 60400 KT = KT + 1
  332. 60410 REM     
  333. 60420 W$ = INKEY$
  334. 60430 IF W$ = "" GOTO 60420
  335. 60440 C = ASC(W$)
  336. 60450 IF C = 0 THEN GOSUB 61900
  337. 60460 IF C = 13 GOTO 60580
  338. 60470 IF C = 17 OR C = 8 GOTO 61150
  339. 60480 IF C = 19 GOTO 60670
  340. 60490 IF C = 4 GOTO 60720
  341. 60500 IF C = 6 GOTO 60780
  342. 60510 IF C = 1 GOTO 60960
  343. 60520 IF KT > MAX GOTO 60410
  344. 60530 IF INSTR(ACT$,W$) = 0 GOTO 61230
  345. 60540 K$(KT) = W$
  346. 60550 PRINT K$(KT);
  347. 60560 IF KT > KTMAX THEN KTMAX = KT
  348. 60570 GOTO 60400
  349. 60580 REM **********  RETURN  **********
  350. 60590 FOR T9 = 1 TO KTMAX
  351. 60600 A$ = A$ + K$(T9)
  352. 60610 NEXT T9
  353. 60620 IF KTMAX = 0 THEN PRINT "1"
  354. 60630 IF KTMAX = 0 THEN DT# = 1
  355. 60640 IF KTMAX = 0 THEN RETURN
  356. 60650 PRINT ""
  357. 60660 GOTO 61260
  358. 60670 REM ********* MOVE CURSE BACK ********
  359. 60680 IF KT = 1 GOTO 60410
  360. 60690 KT = KT - 1
  361. 60700 PRINT CHR$(CH);
  362. 60710 GOTO 60410
  363. 60720 REM ********* MOVE CURSER FORWARD *********
  364. 60730 IF KT >= MAX GOTO 60410
  365. 60740 IF KT > (KTMAX + 1) GOTO 60410
  366. 60750 PRINT K$(KT);
  367. 60760 KT = KT + 1
  368. 60770 GOTO 60410
  369. 60780 REM ********** INSERT ***********
  370. 60790 IF KT > KTMAX GOTO 60410
  371. 60800 X9 = MAX
  372. 60810 WHILE X9 > KT
  373. 60820 X9 = X9 - 1
  374. 60830 K$(X9 + 1) = K$(X9)
  375. 60840 WEND 
  376. 60850 K$(KT) = " "
  377. 60860 KTMAX = KTMAX + 1
  378. 60870 IF KTMAX > MAX THEN KTMAX = MAX
  379. 60880 FOR T9 = KT TO KTMAX
  380. 60890 PRINT K$(T9);
  381. 60900 NEXT T9
  382. 60910 T6 = (KTMAX - KT) + 1
  383. 60920 FOR T7 = 1 TO T6
  384. 60930 PRINT CHR$(CH);
  385. 60940 NEXT T7
  386. 60950 GOTO 60410
  387. 60960 REM ********** DELETE ***********
  388. 60970 IF KT > KTMAX GOTO 60410
  389. 60980 IF KTMAX = 1 GOTO 60410
  390. 60990 K$(MAX + 1) = ""
  391. 61000 X9 = KT 
  392. 61010 WHILE X9 <= MAX
  393. 61020 K$(X9) = K$(X9 + 1)
  394. 61030 X9 = X9 + 1
  395. 61040 WEND 
  396. 61050 KTMAX = KTMAX - 1
  397. 61060 FOR T9 = KT TO KTMAX
  398. 61070 PRINT K$(T9);
  399. 61080 NEXT T9
  400. 61090 PRINT "_";
  401. 61100 T7 = (KTMAX - KT) + 2
  402. 61110 FOR T8 = 1 TO T7
  403. 61120 PRINT CHR$(CH);
  404. 61130 NEXT T8
  405. 61140 GOTO 60410
  406. 61150 REM ********* BACKSPACE ********
  407. 61160 IF KT = 1 GOTO 60410
  408. 61170 KT = KT - 1
  409. 61180 PRINT CHR$(CH);
  410. 61190 K$(KT) = " " 
  411. 61200 PRINT "_";
  412. 61210 PRINT CHR$(CH);
  413. 61220 GOTO 60410
  414. 61230 REM *******  INPUT NOT ACCEPTABLE  ********
  415. 61240 PRINT CHR$(7);
  416. 61250 GOTO 60420
  417. 61260 REM ********* CLEAR STRINGS ********
  418. 61270 MAX = LEN(A$)
  419. 61280 D2$ = ""
  420. 61290 D1$ = ""
  421. 61300 DFLG = 0
  422. 61310 FOR Q93 = 1 TO MAX
  423. 61320 R$ = MID$(A$,Q93,1)
  424. 61330 IF INSTR(DIG$,R$) = 0 GOTO 61400
  425. 61340 IF R$ = "." OR DFLG = 1 GOTO 61380
  426. 61350 IF DFLG = 1 GOTO 61380
  427. 61360 D2$ = D2$ + R$
  428. 61370 GOTO 61400
  429. 61380 D1$ = D1$ + R$
  430. 61390 DFLG = 1
  431. 61400 NEXT Q93
  432. 61410 DA# = VAL(D2$)
  433. 61420 D1# = VAL(D1$)
  434. 61430 DT# = DA# + D1#
  435. 61440 IF K$(1) = "-" THEN DT# =  -DT#   
  436. 61450 RETURN
  437. 61900 REM ****** CHECK FOR ASC0
  438. 61910 S4$ = INKEY$
  439. 61920 C2 =  ASC(S4$)
  440. 61930 IF C2 = 83 THEN C = 1
  441. 61940 IF C2 = 82 THEN C = 6
  442. 61950 IF C2 = 75 THEN C = 19
  443. 61960 IF C2 = 77 THEN C = 4 
  444. 61970 RETURN
  445.  IF C2 = 83